home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / BACKQUOT.LSP < prev    next >
Lisp/Scheme  |  1994-02-05  |  13KB  |  310 lines
  1. ;;;; Backquote-Readmacro
  2. ;;;; Michael Stoll
  3. ;;;; umgeschrieben im Juli/August von Bruno Haible
  4. ;;;; rekursives Backquote 16.-17.8.1989
  5. ;;;; an die übliche Semantik für rekursives Backquote angepaßt am 24.5.1992
  6.  
  7. (in-package "SYSTEM")
  8.  
  9. (proclaim '(special *backquote-level*))
  10. ; NIL oder Anzahl der erlaubten Kommata
  11. ; Wird beim Top-Level-Einsprung in den Reader an NIL gebunden.
  12.  
  13. (proclaim '(special *nsplice-fun*))
  14. (setq *nsplice-fun* 'NCONC) ; Funktion, die ein NSPLICE ausführt
  15. ; (Wird an 'APPEND gebunden für die Produktion der Ausgabe-Form in
  16. ; verschachtelten Backquotes.)
  17.  
  18. ; Bug: Bei verschachtelten Backquotes werden manche Teilformen mehrfach
  19. ; ausgewertet (nämlich z.B. in der ersten Evaluation Formen, die fürs
  20. ; Ausgeben vor der zweiten Evaluation nötig sind) und sollten deshalb
  21. ; seiteneffektfrei sein.
  22.  
  23. (defun \`-reader (stream char)
  24.   (declare (ignore char))
  25.   (let* ((*backquote-level* (1+ (or *backquote-level* 0)))
  26.          (skel (read stream t nil t))
  27.          (form (list 'BACKQUOTE
  28.                      (remove-backquote-third skel)
  29.                      (backquote-1 (unquote-level skel))
  30.         ))     )
  31.     (when (= *backquote-level* 1) (setq form (elim-unquote-dummy form)))
  32.     form
  33. ) )
  34.  
  35. (defun \,-reader (stream char &aux (c (peek-char nil stream)))
  36.   (declare (ignore char))
  37.   (cond ((null *backquote-level*)
  38.          (error #+DEUTSCH "~S: Komma darf nur innerhalb von Backquote auftreten."
  39.                 #+ENGLISH "~S: comma is illegal outside of backquote"
  40.                 #+FRANCAIS "~S : Une virgule ne peut apparaître qu'à l'intérieur d'un «backquote»."
  41.                 'read
  42.         ))
  43.         ((zerop *backquote-level*)
  44.          (error #+DEUTSCH "~S: Es dürfen nicht mehr Kommata als Backquotes auftreten."
  45.                 #+ENGLISH "~S: more commas out than backquotes in, is illegal"
  46.                 #+FRANCAIS "~S : Il ne peut y avoir plus de virgules que de «backquote»."
  47.                 'read
  48.         ))
  49.         (t (let ((*backquote-level* (1- *backquote-level*)))
  50.              (cond ((eql c #\@)
  51.                     (read-char stream)
  52.                     (list 'SPLICE (list 'UNQUOTE (read stream t nil t)))
  53.                    )
  54.                    ((eql c #\.)
  55.                     (read-char stream)
  56.                     (list 'NSPLICE (list 'UNQUOTE (read stream t nil t)))
  57.                    )
  58.                    (t (list 'UNQUOTE (read stream t nil t)))
  59. ) )     )  ) )
  60.  
  61. ;(set-macro-character #\` #'\`-reader)
  62. ;(set-macro-character #\, #'\,-reader)
  63.  
  64. ; Ausgabe von ...                              als ...
  65. ; (backquote original-form [expanded-form])    `original-form
  66. ; (splice (unquote form))                      ,@form
  67. ; (splice form)                                ,@'form
  68. ; (nsplice (unquote form))                     ,.form
  69. ; (nsplice form)                               ,.'form
  70. ; (unquote form)                               ,form
  71.  
  72. ;(defmacro backquote (original-form expanded-form)
  73. ;  (declare (ignore original-form))
  74. ;  expanded-form
  75. ;)
  76.  
  77. (defun remove-backquote-third (skel)
  78.   (cond ((atom skel)
  79.          (if (simple-vector-p skel)
  80.            (map 'vector #'remove-backquote-third skel)
  81.            skel
  82.         ))
  83.         ((and (eq (car skel) 'BACKQUOTE) (consp (cdr skel)))
  84.          (list 'BACKQUOTE (second skel)) ; ohne drittes Element der Liste
  85.         )
  86.         (t (cons (remove-backquote-third (car skel))
  87.                  (remove-backquote-third (cdr skel))
  88. ) )     )  )
  89.  
  90. ; ersetzt UNQUOTE-DUMMY durch UNQUOTE.
  91. (defun elim-unquote-dummy (skel)
  92.   (if (atom skel)
  93.     (cond ((eq skel 'UNQUOTE-DUMMY) 'UNQUOTE)
  94.           ((simple-vector-p skel) (map 'vector #'elim-unquote-dummy skel))
  95.           (t skel)
  96.     )
  97.     (let* ((car (car skel)) (newcar (elim-unquote-dummy car))
  98.            (cdr (cdr skel)) (newcdr (elim-unquote-dummy cdr)))
  99.       (if (and (eq car newcar) (eq cdr newcdr))
  100.         skel
  101.         (cons newcar newcdr)
  102. ) ) ) )
  103.  
  104. ;; wandelt im "Skelett" skel alle UNQUOTEs der Stufe level+1 (d.h. innerhalb
  105. ;; von level-fachem UNQUOTE) in UNQUOTE-VALUE um.
  106. (defun unquote-level (skel &optional (level 0))
  107.   (if (atom skel)
  108.     (if (simple-vector-p skel)
  109.       (map 'vector #'(lambda (subskel) (unquote-level subskel level)) skel)
  110.       skel
  111.     )
  112.     ; skel ist ein Cons
  113.     (cond ((and (eq (first skel) 'UNQUOTE) (consp (rest skel)))
  114.            (if (zerop level)
  115.              (list 'UNQUOTE-VALUE (second skel))
  116.              (let ((weiteres (unquote-level (second skel) (1- level))))
  117.                ; Vereinfache (UNQUOTE weiteres):
  118.                (if (and (consp weiteres) (eq (car weiteres) 'QUOTE)
  119.                         (consp (second weiteres))
  120.                         (eq (car (second weiteres)) 'UNQUOTE-VALUE)
  121.                    )
  122.                  ; (UNQUOTE (QUOTE (UNQUOTE-VALUE ...))) -> (UNQUOTE-VALUE ...)
  123.                  (second weiteres)
  124.                  (list 'UNQUOTE weiteres)
  125.           )) ) )
  126.           ((and (eq (first skel) 'BACKQUOTE) (consp (rest skel)))
  127.            (list* 'BACKQUOTE
  128.                   (unquote-level (second skel) (1+ level))
  129.                   (if (consp (cddr skel))
  130.                     (list (unquote-level (third skel) level))
  131.                     nil
  132.           ))      )
  133.           (t ; CAR-CDR-Rekursion
  134.             (cons (unquote-level (car skel) level)
  135.                   (unquote-level (cdr skel) level)
  136. ) ) )     ) )
  137.  
  138. ;; stellt fest, ob eine Form zu mehreren expandieren kann.
  139. (defun splicing-p (skel)
  140.   (and (consp skel)
  141.        (let ((h (first skel))) (or (eq h 'splice) (eq h 'nsplice)))
  142. ) )
  143.  
  144. ;; wandelt "Skelett" skel (mit UNQUOTE-VALUEs etc.) in passenden Code um.
  145. (defun backquote-1 (skel)
  146.   (if (atom skel)
  147.     (cond ((or (and (symbolp skel) (constantp skel) (eq skel (symbol-value skel)))
  148.                (numberp skel)
  149.                (stringp skel)
  150.                (bit-vector-p skel)
  151.            )
  152.            ; Konstanten, die zu sich selbst evaluieren, bleiben unverändert
  153.            skel
  154.           )
  155.           ((simple-vector-p skel)
  156.            ; Vektoren:
  157.            ; #(... item ...) -> (VECTOR ... item ...)
  158.            ; #(... ,@form ...) ->
  159.            ;   (MULTIPLE-VALUE-CALL #'VECTOR ... (VALUES-LIST form) ...)
  160.            (if (some #'splicing-p skel)
  161.              (list* 'MULTIPLE-VALUE-CALL
  162.                     '(FUNCTION VECTOR)
  163.                     (map 'list
  164.                          #'(lambda (subskel)
  165.                              (if (splicing-p subskel)
  166.                                (if (and (consp (second subskel))
  167.                                         (eq (first (second subskel)) 'UNQUOTE-VALUE)
  168.                                    )
  169.                                  (list 'VALUES-LIST (backquote-1 (second subskel)))
  170.                                  ; SPLICE bzw. NSPLICE für später aufheben
  171.                                  (backquote-cons (backquote-1 (first subskel))
  172.                                                  (backquote-1 (rest subskel))
  173.                                ) )
  174.                                (list 'VALUES (backquote-1 subskel))
  175.                            ) )
  176.                          skel
  177.              )      )
  178.              (let ((einzelne (map 'list #'backquote-1 skel)))
  179.                (if (every #'constantp einzelne)
  180.                  ; alle Teile konstant -> sofort zusammensetzen
  181.                  (list 'QUOTE (map 'vector #'eval einzelne))
  182.                  (cons 'VECTOR einzelne)
  183.              ) )
  184.           ))
  185.           (t
  186.            ; sonstige Atome A in 'A umwandeln
  187.            (list 'QUOTE skel)
  188.     )     )
  189.     (cond ((eq (first skel) 'unquote-value)
  190.            ; ,form im richtigen Level wird zu form
  191.            (second skel)
  192.           )
  193.           ((eq (first skel) 'splice)
  194.            ; ,@form ist verboten
  195.            (error #+DEUTSCH "Die Syntax ,@form ist nur innerhalb von Listen erlaubt."
  196.                   #+ENGLISH "The syntax ,@form is valid only in lists"
  197.                   #+FRANCAIS "La syntaxe ,@form n'est permise qu'à l'intérieur d'une liste."
  198.           ))
  199.           ((eq (first skel) 'nsplice)
  200.            ; ,.form ist verboten
  201.            (error #+DEUTSCH "Die Syntax ,.form ist nur innerhalb von Listen erlaubt."
  202.                   #+ENGLISH "The syntax ,.form is valid only in lists"
  203.                   #+FRANCAIS "La syntaxe ,.form n'est permise qu'à l'intérieur d'une liste."
  204.           ))
  205.           ((and (eq (first skel) 'backquote) (consp (rest skel)))
  206.            ; verschachtelte Backquotes
  207.            (list* 'LIST
  208.                   ''BACKQUOTE
  209.                   (let ((*nsplice-fun* 'APPEND)) (backquote-1 (second skel)))
  210.                   (if (consp (cddr skel))
  211.                     (list (backquote-1 (third skel)))
  212.                     nil
  213.           ))      )
  214.           ((and (consp (first skel))
  215.                 (eq (first (first skel)) 'splice)
  216.            )
  217.            ; (  ... ,@EXPR ...  ) behandeln
  218.            (if (and (consp (second (first skel)))
  219.                     (eq (first (second (first skel))) 'UNQUOTE-VALUE)
  220.                )
  221.              (backquote-append (backquote-1 (second (first skel)))
  222.                                (backquote-1 (rest skel))
  223.              )
  224.              ; SPLICE für später aufheben
  225.              (backquote-cons
  226.                (backquote-cons (backquote-1 (first (first skel)))
  227.                                (backquote-1 (rest (first skel)))
  228.                )
  229.                (backquote-1 (rest skel))
  230.           )) )
  231.           ((and (consp (first skel))
  232.                 (eq (first (first skel)) 'nsplice)
  233.            )
  234.            ; (  ... ,.EXPR ...  ) behandeln
  235.            (if (and (consp (second (first skel)))
  236.                     (eq (first (second (first skel))) 'UNQUOTE-VALUE)
  237.                )
  238.              (let ((erstes (backquote-1 (second (first skel))))
  239.                    (weiteres (backquote-1 (rest skel))))
  240.                ; (NCONC erstes weiteres) vereinfachen
  241.                (cond ((null weiteres)
  242.                       ; (NCONC expr NIL) -> (NCONC expr) -> expr
  243.                       (if (splicing-p erstes)
  244.                         (list *nsplice-fun* erstes)
  245.                         erstes
  246.                      ))
  247.                      ((and (consp weiteres) (eq (first weiteres) *nsplice-fun*))
  248.                       ; (NCONC expr (NCONC . rest)) -> (NCONC expr . rest)
  249.                       (list* *nsplice-fun* erstes (rest weiteres)) )
  250.                      (t (list *nsplice-fun* erstes weiteres))
  251.              ) )
  252.              ; NSPLICE für später aufheben
  253.              (backquote-cons
  254.                (backquote-cons (backquote-1 (first (first skel)))
  255.                                (backquote-1 (rest (first skel)))
  256.                )
  257.                (backquote-1 (rest skel))
  258.           )) )
  259.           (t ; sonst CAR und CDR zusammensetzen
  260.              (backquote-cons (backquote-1 (first skel)) (backquote-1 (rest skel)))
  261.           )
  262. ) ) )
  263.  
  264. ; Liefert die Form, die das Append-Ergebnis der Formen erstes und weiteres
  265. ; ergibt.
  266. (defun backquote-append (erstes weiteres)
  267.   ; (APPEND erstes weiteres) vereinfachen
  268.   (cond ((null weiteres)
  269.          ; (APPEND expr NIL) -> (APPEND expr) -> expr
  270.          (if (splicing-p erstes)
  271.            (list 'APPEND erstes)
  272.            erstes
  273.         ))
  274.         ((and (consp weiteres) (eq (first weiteres) 'append))
  275.          ; (APPEND expr (APPEND . rest)) -> (APPEND expr . rest)
  276.          (list* 'APPEND erstes (rest weiteres)) )
  277.         (t (list 'APPEND erstes weiteres))
  278. ) )
  279.  
  280. ; Liefert die Form, die das Cons-Ergebnis der Formen erstes und weiteres
  281. ; ergibt.
  282. (defun backquote-cons (erstes weiteres)
  283.   ; (CONS erstes weiteres) vereinfachen
  284.   (cond ((and (constantp erstes) (constantp weiteres))
  285.          ; beide Teile konstant -> sofort zusammensetzen
  286.          (setq erstes (eval erstes))
  287.          (setq weiteres (eval weiteres))
  288.          (list 'QUOTE
  289.            (cons (if (eq erstes 'UNQUOTE) 'UNQUOTE-DUMMY erstes) weiteres)
  290.         ))
  291.         ((null weiteres)
  292.          ; (CONS expr NIL) -> (LIST expr)
  293.          (list 'LIST erstes)
  294.         )
  295.         ((atom weiteres)
  296.          (list 'CONS erstes weiteres) ; ohne Vereinfachung
  297.         )
  298.         ((eq (first weiteres) 'LIST)
  299.          ; (CONS expr (LIST . rest)) -> (LIST expr . rest)
  300.          (list* 'LIST erstes (rest weiteres))
  301.         )
  302.         ((or (eq (first weiteres) 'LIST*) (eq (first weiteres) 'CONS))
  303.          ; (CONS expr (LIST* . rest)) -> (LIST* expr . rest)
  304.          ; (CONS expr1 (CONS expr2 expr3)) -> (LIST* expr1 expr2 expr3)
  305.          (list* 'LIST* erstes (rest weiteres))
  306.         )
  307.         (t (list 'CONS erstes weiteres)) ; ohne Vereinfachung
  308. ) )
  309.  
  310.